home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / disdef.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  19.4 KB  |  462 lines
  1. ;; -*- Mode: LISP; Package:(BOXER GLOBAL 1000); Base: 8.; Fonts:CPTFONT -*-
  2.  
  3. ;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15.  
  16. ;;;this file contains all the macro and defsubsts
  17. ;;;for the display code
  18.  
  19. ;;;NOTE:it must be loaded before any of the other display files
  20.  
  21. (DEFSUBST MAKE-SCREEN-CHA (ACTUAL-CHA)
  22.   ACTUAL-CHA)
  23.  
  24. (DEfSUBST SCREEN-CHA? (SC) (FIXNUMP SC))
  25.  
  26. (DEFUN CHA-WIDTH (CHA)
  27.   (CHA-WID (FONT-NO CHA) (CHA-CODE CHA)))
  28.  
  29. (DEFVAR FREE-SCREEN-ROWS NIL
  30.   "A list of free screen-rows.")
  31.  
  32. (DEFVAR FREE-SCREEN-BOXS NIL
  33.   "A list of free screen-boxs.")
  34.  
  35. (DEFVAR FREE-GRAPHICS-SCREEN-BOXS NIL
  36.   "A list of free graphics-screen-boxs.")
  37.  
  38. (DEFVAR INITIAL-NO-OF-FREE-SCREEN-ROWS 150.)
  39.  
  40. (DEFVAR INITIAL-NO-OF-FREE-SCREEN-BOXS 600.)
  41.  
  42. (DEFVAR INITIAL-NO-OF-FREE-GRAPHICS-SCREEN-BOXS 50.)
  43.  
  44. (DEFSUBST ALLOCATE-GRAPHICS-SCREEN-BOX-INTERNAL (GRAPHICS-BOX)
  45.   (LET ((GRAPHICS-SCREEN-BOX (OR (POP FREE-GRAPHICS-SCREEN-BOXS)
  46.                  (MAKE-INSTANCE 'GRAPHICS-SCREEN-BOX))))
  47.     (TELL GRAPHICS-SCREEN-BOX :RE-INIT GRAPHICS-BOX)
  48.     GRAPHICS-SCREEN-BOX))
  49.  
  50. (DEFUN ACTUAL-OBJ-OF-SCREEN-OBJ (SCREEN-OBJ)
  51.   (IF (SCREEN-CHA? SCREEN-OBJ)
  52.       SCREEN-OBJ
  53.       (SCREEN-OBJ-ACTUAL-OBJ SCREEN-OBJ)))
  54.  
  55. (DEFSUBST ALLOCATE-SCREEN-ROW-INTERNAL (ACTUAL-ROW)
  56.   (LET ((SCREEN-ROW (OR (POP FREE-SCREEN-ROWS) (MAKE-INSTANCE 'SCREEN-ROW))))
  57.     (TELL SCREEN-ROW :RE-INIT ACTUAL-ROW)
  58.     SCREEN-ROW))
  59.  
  60. (DEFSUBST ALLOCATE-SCREEN-BOX-INTERNAL (ACTUAL-BOX)
  61.   (LET ((SCREEN-BOX (OR (POP FREE-SCREEN-BOXS) (MAKE-INSTANCE 'SCREEN-BOX))))
  62.     (TELL SCREEN-BOX :RE-INIT ACTUAL-BOX)
  63.     SCREEN-BOX))
  64.  
  65. (DEFSUBST ALLOCATE-GRAPHICS-SCREEN-SHEET-INTERNAL (GRAPHICS-SHEET)
  66.   (MAKE-GRAPHICS-SCREEN-SHEET GRAPHICS-SHEET))
  67.  
  68.  
  69. (DEFSUBST ALLOCATE-SCREEN-OBJ-INTERNAL (ACTUAL-OBJ)
  70.   (COND ((GRAPHICS-BOX? ACTUAL-OBJ) (ALLOCATE-GRAPHICS-SCREEN-BOX-INTERNAL ACTUAL-OBJ))
  71.     ((and (port-box? actual-obj) (graphics-box? (tell actual-obj :ports)))
  72.      (ALLOCATE-GRAPHICS-SCREEN-BOX-INTERNAL ACTUAL-OBJ))
  73.     ((BOX? ACTUAL-OBJ) (ALLOCATE-SCREEN-BOX-INTERNAL ACTUAL-OBJ))
  74.     ((ROW? ACTUAL-OBJ) (ALLOCATE-SCREEN-ROW-INTERNAL ACTUAL-OBJ))
  75.     ((GRAPHICS-SHEET? ACTUAL-OBJ) (ALLOCATE-GRAPHICS-SCREEN-SHEET-INTERNAL ACTUAL-OBJ))
  76.     (T (BARF 'BOXER-REDISPLAY-ERROR :FORMAT-CTL "Can't allocate a screen-obj for ~S"
  77.          :FORMAT-ARG ACTUAL-OBJ))))
  78.  
  79. (DEFSUBST DEALLOCATE-SCREEN-ROW-INTERNAL (SCREEN-ROW)
  80.   (PUSH SCREEN-ROW FREE-SCREEN-ROWS))
  81.  
  82. (DEFSUBST DEALLOCATE-SCREEN-BOX-INTERNAL (SCREEN-BOX)
  83.   (PUSH SCREEN-BOX FREE-SCREEN-BOXS))
  84.  
  85. (DEFSUBST DEALLOCATE-GRAPHICS-SCREEN-BOX-INTERNAL (GRAPHICS-SCREEN-BOX)
  86.   (PUSH GRAPHICS-SCREEN-BOX FREE-GRAPHICS-SCREEN-BOXS))
  87.  
  88. (DEFSUBST DEALLOCATE-SCREEN-OBJ-INTERNAL (SCREEN-OBJ)
  89.   (COND ((GRAPHICS-SCREEN-BOX? SCREEN-OBJ)
  90.      (DEALLOCATE-GRAPHICS-SCREEN-BOX-INTERNAL SCREEN-OBJ))
  91.     ((SCREEN-BOX? SCREEN-OBJ) (DEALLOCATE-SCREEN-BOX-INTERNAL SCREEN-OBJ))
  92.     ((SCREEN-ROW? SCREEN-OBJ) (DEALLOCATE-SCREEN-ROW-INTERNAL SCREEN-OBJ))
  93.     (T (BARF 'BOXER-REDSIPLAY-ERROR :FORMAT-CTL "Can't deallocate ~S"
  94.          :FORMAT-ARG SCREEN-OBJ))))
  95.  
  96. (DEFSUBST BOX-BORDERS-FN-TYPE-LABEL-STRING (BOX-TYPE)
  97.   (GET BOX-TYPE ':BOX-BORDERS-FN-TYPE-LABEL-STRING))
  98. (DEFSUBST BOX-BORDERS-FN-TYPE-LABEL-FONT-NO (BOX-TYPE)
  99.   (GET BOX-TYPE ':BOXER-BORDERS-TYPE-LABEL-FONT-NO))
  100. (DEFSUBST BOX-BORDERS-FN-TYPE-LABEL-INDENTATION (BOX-TYPE)
  101.   (GET BOX-TYPE ':BOX-BORDERS-FN-TYPE-LABEL-INDENTATION))
  102. (DEFSUBST BOX-BORDERS-FN-BORDER-WID (BOX-TYPE)
  103.   (GET BOX-TYPE ':BOX-BORDERS-FN-BORDER-WIDTH))
  104. (DEFSUBST BOX-BORDERS-FN-BORDER-SPA (BOX-TYPE)
  105.   (GET BOX-TYPE ':BOX-BORDERS-FN-BORDER-SPA))
  106. (DEFSUBST BOX-BORDERS-FN-NAME-BORDER-SPA (BOX-TYPE)
  107.   (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-BORDER-SPA))
  108. (DEFSUBST BOX-BORDERS-FN-NAME-BORDER-WID (BOX-TYPE)
  109.   (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-BORDER-WID))
  110. (DEFSUBST BOX-BORDERS-FN-NAME-HIGHLIGHT (BOX-TYPE)
  111.   (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-HIGHLIGHT))
  112.  
  113. (DEFSUBST BOX-BORDERS-FN-SET-TYPE-LABEL-STRING (BOX-TYPE NEW-VALUE)
  114.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-TYPE-LABEL-STRING) NEW-VALUE))
  115. (DEFSUBST BOX-BORDERS-FN-SET-TYPE-LABEL-FONT-NO (BOX-TYPE NEW-VALUE)
  116.   (SETF (GET BOX-TYPE ':BOXER-BORDERS-TYPE-LABEL-FONT-NO) NEW-VALUE))
  117. (DEFSUBST BOX-BORDERS-FN-SET-TYPE-LABEL-INDENTATION (BOX-TYPE NEW-VALUE)
  118.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-TYPE-LABEL-INDENTATION) NEW-VALUE))
  119. (DEFSUBST BOX-BORDERS-FN-SET-BORDER-WID (BOX-TYPE NEW-VALUE)
  120.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-BORDER-WIDTH) NEW-VALUE))
  121. (DEFSUBST BOX-BORDERS-FN-SET-BORDER-SPA (BOX-TYPE NEW-VALUE)
  122.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-BORDER-SPA) NEW-VALUE))
  123. (DEFSUBST BOX-BORDERS-FN-SET-NAME-BORDER-SPA (BOX-TYPE NEW-VALUE)
  124.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-BORDER-SPA) NEW-VALUE))
  125. (DEFSUBST BOX-BORDERS-FN-SET-NAME-BORDER-WID (BOX-TYPE NEW-VALUE)
  126.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-BORDER-WID) NEW-VALUE))
  127. (DEFSUBST BOX-BORDERS-FN-SET-NAME-HIGHLIGHT (BOX-TYPE NEW-VALUE)
  128.   (SETF (GET BOX-TYPE ':BOX-BORDERS-FN-NAME-HIGHLIGHT) NEW-VALUE))
  129.  
  130. (DEFSUBST REGION-WID (REGION)
  131.   (SYMEVAL-IN-INSTANCE REGION 'TV:WIDTH))
  132.  
  133. (DEFSUBST REGION-HEI (REGION)
  134.   (SYMEVAL-IN-INSTANCE REGION 'TV:HEIGHT))
  135.  
  136. (DEFSUBST REGION-X (REGION)
  137.   (TV:BLINKER-X-POS REGION))
  138.  
  139. (DEFSUBST REGION-Y (REGION)
  140.   (TV:BLINKER-Y-POS REGION))
  141.  
  142. (DEFSUBST REGION-VISIBILITY (REGION)
  143.   (TV:BLINKER-VISIBILITY REGION))
  144.  
  145. (DEFMACRO USING-BOX-BORDERS-BLINKER ((VAR) &BODY BODY)
  146.   `(USING-RESOURCE (,VAR BOX-BORDERS-BLINKER)
  147.      (UNWIND-PROTECT
  148.        (PROGN . ,BODY)
  149.        (TELL ,VAR :SET-VISIBILITY NIL))))
  150.  
  151. (DEFRESOURCE BOX-BORDERS-BLINKER ()
  152.   :CONSTRUCTOR (TV:MAKE-BLINKER *BOXER-PANE* 'BOX-BORDERS-BLINKER)
  153.   :MATCHER (PROGN OBJECT T))
  154.  
  155. (DEFSUBST DISPLAY-NAME-TAB? (SCREEN-BOX)
  156.   (NEQ SCREEN-BOX *OUTERMOST-SCREEN-BOX*))
  157.  
  158. (DEFMACRO BOX-BORDERS-FN-BIND-CONSTANT-VALUES (&BODY BODY)
  159.   `(LET*
  160.      ((TYPE-LABEL-STRING  (BOX-BORDERS-FN-TYPE-LABEL-STRING BOX-TYPE))
  161.       (TYPE-LABEL-FONT-NO (BOX-BORDERS-FN-TYPE-LABEL-FONT-NO BOX-TYPE))
  162.       (TYPE-LABEL-INDENTATION (BOX-BORDERS-FN-TYPE-LABEL-INDENTATION BOX-TYPE))
  163.       (BORDER-WID (BOX-BORDERS-FN-BORDER-WID BOX-TYPE))
  164.       (BORDER-SPA (BOX-BORDERS-FN-BORDER-SPA BOX-TYPE))
  165.       (NAME-BORDER-SPA (BOX-BORDERS-FN-NAME-BORDER-SPA BOX-TYPE))
  166.       (NAME-BORDER-WID (BOX-BORDERS-FN-NAME-BORDER-WID BOX-TYPE))
  167.       (NAME-HIGHLIGHT (BOX-BORDERS-FN-NAME-HIGHLIGHT BOX-TYPE))
  168.       ;; Now we start computing various parameters.
  169.       (TYPE-LABEL-WID (STRING-WID TYPE-LABEL-FONT-NO TYPE-LABEL-STRING))
  170.       (TYPE-LABEL-HEI (STRING-HEI TYPE-LABEL-FONT-NO)))
  171.      ;; Prevent bound but never use errors
  172.      NAME-BORDER-SPA NAME-BORDER-WID NAME-HIGHLIGHT
  173.       . ,BODY))
  174.  
  175. (DEFMACRO BOX-BORDERS-FN-BIND-INTERESTING-VALUES (&BODY BODY)
  176.   `(BOX-BORDERS-FN-BIND-CONSTANT-VALUES
  177.      (LET* (;; Look for a naming row and its screen representation
  178.         (NAME-ROW (TELL (TELL-CHECK-NIL SCREEN-BOX :ACTUAL-OBJ) :NAME-ROW))
  179.         (SHOW-NAME-ROW (AND NAME-ROW (DISPLAY-NAME-TAB? SCREEN-BOX))))
  180.        . ,BODY)))
  181.  
  182. (DEFMACRO BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS ((OLD-NAME-P) &BODY BODY)
  183.   `(LET*
  184.      ((NAME-ROW-WID (STRING-WID (OR (FONT-NO (CAR (TELL NAME-ROW :CHAS)))
  185.                          *FONT-NUMBER-FOR-NAMING*)
  186.                 (IF ,OLD-NAME-P (TELL SCREEN-BOX :NAME)
  187.                     (TELL NAME-ROW :TEXT-STRING))))
  188.       (NAME-ROW-HEI (STRING-HEI (OR (FONT-NO (CAR (TELL NAME-ROW :CHAS)))
  189.                          *FONT-NUMBER-FOR-NAMING*)))
  190.       (NAME-TAB-WID (+ NAME-ROW-WID (* 2 NAME-BORDER-WID) (* 2 NAME-BORDER-SPA)))
  191.       (NAME-TAB-HEI (+ NAME-ROW-HEI (* 2 NAME-BORDER-WID) (* 2 NAME-BORDER-SPA)))
  192.       (BOX-WID (- OUTER-WID (* 2 BORDER-SPA)))
  193.       (BOX-HEI (- OUTER-HEI (* 2 BORDER-SPA) (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  194.       (BOX-INNER-WID (- BOX-WID (* 2 BORDER-WID) NAME-TAB-WID))
  195.       (TAB-INNER-WID (- NAME-TAB-WID (* 2 NAME-BORDER-WID)))
  196.       ;; Now calculate the positions of things like the BOX itself...
  197.       (BOX-LEF (+ X BORDER-SPA NAME-TAB-WID))
  198.       (BOX-RIG (- (+ X OUTER-WID) BORDER-SPA))
  199.       (BOX-TOP (+ Y BORDER-SPA (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  200.       (BOX-BOT (- (+ Y OUTER-HEI) BORDER-SPA))
  201.       ;; ...the name tag and...
  202.       (TAB-LEF (+ X BORDER-SPA))
  203.       (TAB-RIG (+ X BORDER-SPA NAME-TAB-WID))
  204.       (TAB-TOP (+ Y BORDER-SPA (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  205.       (TAB-BOT (+ TAB-TOP NAME-TAB-HEI))
  206.       ;; ...the box's type label
  207.       (TYPE-LABEL-LEF (+ BOX-LEF BORDER-WID TYPE-LABEL-INDENTATION))
  208.       (TYPE-LABEL-RIG (+ TYPE-LABEL-LEF TYPE-LABEL-WID))
  209.       (TYPE-LABEL-TOP (+ Y BORDER-SPA (// (MAX 0 (- BORDER-WID TYPE-LABEL-HEI)) 2))))
  210.      ;; Prevent bound but never used errors
  211.      BOX-HEI BOX-INNER-WID BOX-RIG BOX-TOP BOX-BOT
  212.      TAB-BOT TAB-RIG TAB-LEF TAB-INNER-WID
  213.      TYPE-LABEL-RIG TYPE-LABEL-TOP
  214.      . ,BODY))
  215.  
  216. (DEFMACRO BOX-BORDERS-FN-BIND-UNNAMED-BOX-PARAMETERS (&BODY BODY)
  217.   `(LET*
  218.      ((BOX-WID (- OUTER-WID (* 2 BORDER-SPA)))
  219.       (BOX-HEI (- OUTER-HEI (* 2 BORDER-SPA) (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  220.       (BOX-INNER-WID (- BOX-WID (* 2 BORDER-WID)))
  221.       (BOX-LEF (+ X BORDER-SPA))
  222.       (BOX-RIG (- (+ X OUTER-WID) BORDER-SPA))
  223.       (BOX-TOP (+ Y BORDER-SPA (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  224.       (BOX-BOT (- (+ Y OUTER-HEI) BORDER-SPA))
  225.       (TYPE-LABEL-LEF (+ BOX-LEF BORDER-WID TYPE-LABEL-INDENTATION))
  226.       (TYPE-LABEL-RIG (+ TYPE-LABEL-LEF TYPE-LABEL-WID))
  227.       (TYPE-LABEL-TOP (+ Y BORDER-SPA (// (MAX 0 (- BORDER-WID TYPE-LABEL-HEI)) 2))))
  228.      ;; Prevent bound but never used errors
  229.      BOX-HEI BOX-INNER-WID BOX-RIG BOX-TOP BOX-BOT TYPE-LABEL-RIG TYPE-LABEL-TOP
  230.      . ,BODY))
  231.  
  232. ;;; Border drawing Macros
  233.  
  234. (DEFVAR *PORT-BOX-BORDER-GAP* 3
  235.   "The amount of whitespace in between the inner and outer box border of a port. ")
  236.  
  237. (DEFMACRO DRAW-BOX-BORDERS ()
  238.   `(PROGN
  239.      ;; Left, right, and bottom of the box.    
  240.      (DRAW-RECTANGLE TV:ALU-XOR
  241.              BORDER-WID                            BOX-HEI
  242.              BOX-LEF                               BOX-TOP)
  243.      (DRAW-RECTANGLE TV:ALU-XOR
  244.              BORDER-WID                            BOX-HEI
  245.              (- BOX-RIG BORDER-WID)                BOX-TOP)
  246.      (DRAW-RECTANGLE TV:ALU-XOR
  247.              BOX-INNER-WID                         BORDER-WID
  248.              (+ BOX-LEF BORDER-WID)                (- BOX-BOT BORDER-WID))
  249.      ;; Left and right part of the top line.
  250.      (DRAW-RECTANGLE TV:ALU-XOR
  251.              (- TYPE-LABEL-LEF BORDER-WID BOX-LEF) BORDER-WID
  252.              (+ BOX-LEF BORDER-WID)                BOX-TOP)
  253.      (DRAW-RECTANGLE TV:ALU-XOR
  254.              (- BOX-RIG BORDER-WID TYPE-LABEL-RIG) BORDER-WID
  255.              TYPE-LABEL-RIG                        BOX-TOP)
  256.      ;; Type label string.
  257.      (DRAW-STRING
  258.        TV:ALU-XOR TYPE-LABEL-FONT-NO TYPE-LABEL-STRING
  259.        TYPE-LABEL-LEF TYPE-LABEL-TOP)
  260.      (WHEN (EQ BOX-TYPE ':PORT-BOX)
  261.        ;; bind some useful values
  262.        (LET ((INNER-BOX-LENGTH-DIFFERENCE (+ (* 2 *PORT-BOX-BORDER-GAP*) (* 2 BORDER-WID)))
  263.          (INNER-BOX-OFFSET-DIFFERENCE (+ *PORT-BOX-BORDER-GAP* BORDER-WID))
  264.          (TYPE-LABEL-HEI-OFFSET (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)))
  265.      ;; first, we draw the inner box (left, top, right, bottom)
  266.      (DRAW-RECTANGLE TV:ALU-XOR
  267.              BORDER-WID
  268.              (- BOX-HEI INNER-BOX-OFFSET-DIFFERENCE BORDER-SPA
  269.                 TYPE-LABEL-HEI-OFFSET)
  270.              (+ BOX-LEF INNER-BOX-OFFSET-DIFFERENCE)
  271.              (+ BOX-TOP TYPE-LABEL-HEI-OFFSET BORDER-SPA))
  272.      (DRAW-RECTANGLE TV:ALU-XOR
  273.              (- BOX-INNER-WID INNER-BOX-LENGTH-DIFFERENCE) BORDER-WID
  274.              (+ BOX-LEF INNER-BOX-OFFSET-DIFFERENCE BORDER-WID)
  275.              (+ BOX-TOP TYPE-LABEL-HEI-OFFSET BORDER-SPA))
  276.      (DRAW-RECTANGLE TV:ALU-XOR
  277.              BORDER-WID
  278.              (- BOX-HEI INNER-BOX-OFFSET-DIFFERENCE BORDER-SPA
  279.                 TYPE-LABEL-HEI-OFFSET)
  280.              (- BOX-RIG BORDER-WID INNER-BOX-OFFSET-DIFFERENCE)
  281.              (+ BOX-TOP TYPE-LABEL-HEI-OFFSET BORDER-SPA))
  282.      (DRAW-RECTANGLE TV:ALU-XOR
  283.              (- BOX-INNER-WID INNER-BOX-LENGTH-DIFFERENCE) BORDER-WID
  284.              (+ BOX-LEF INNER-BOX-OFFSET-DIFFERENCE BORDER-WID)
  285.              (- BOX-BOT BORDER-WID INNER-BOX-OFFSET-DIFFERENCE))
  286.      ;; Now we draw the connecting struts (top-left, top-right, bot-left, bot-right)
  287.      (DRAW-LINE (+ BOX-LEF BORDER-WID) (+ BOX-TOP BORDER-WID)
  288.             (+ BOX-LEF INNER-BOX-OFFSET-DIFFERENCE)
  289.             (+ BOX-TOP TYPE-LABEL-HEI-OFFSET BORDER-SPA)
  290.             TV:ALU-XOR NIL)
  291.      (DRAW-LINE (- BOX-RIG BORDER-WID 1) (+ BOX-TOP BORDER-WID)
  292.             (- BOX-RIG INNER-BOX-OFFSET-DIFFERENCE)
  293.             (+ BOX-TOP TYPE-LABEL-HEI-OFFSET BORDER-SPA)
  294.             TV:ALU-XOR T)
  295.      (DRAW-LINE (+ BOX-LEF BORDER-WID) (- BOX-BOT BORDER-WID 1)
  296.             (+ BOX-LEF INNER-BOX-OFFSET-DIFFERENCE)
  297.             (- BOX-BOT INNER-BOX-OFFSET-DIFFERENCE 1)
  298.             TV:ALU-XOR NIL)
  299.      (DRAW-LINE (- BOX-RIG BORDER-WID 1) (- BOX-BOT BORDER-WID 1)
  300.             (- BOX-RIG INNER-BOX-OFFSET-DIFFERENCE)
  301.             (- BOX-BOT INNER-BOX-OFFSET-DIFFERENCE 1)
  302.             TV:ALU-XOR T)))))
  303.  
  304. (DEFMACRO DRAW-SCREEN-ROW-FOR-NAMING ()
  305.   ;; We can't just use :REDISPLAY-PASS-2 for screen-rows here because this function has to
  306.   ;; have the property that it will erase itself if drawn twice
  307.   `(LET* ((STRING-TO-DRAW (IF OLD-P
  308.                 (TELL SCREEN-BOX :NAME)
  309.                 (TELL NAME-ROW :TEXT-STRING)))
  310.         (EMPTY-P (TELL NAME-ROW :CHAS))
  311.         (STRING-FONT (IF (NULL EMPTY-P) *FONT-NUMBER-FOR-NAMING*
  312.                  (FONT-NO (CAR (TELL NAME-ROW :CHAS))))))
  313.        (IF OLD-P
  314.        (DRAW-STRING TV:ALU-XOR STRING-FONT STRING-TO-DRAW
  315.             (+ TAB-LEF NAME-BORDER-WID NAME-BORDER-SPA)
  316.             (+ TAB-TOP NAME-BORDER-WID NAME-BORDER-SPA))
  317.        (WHEN EMPTY-P
  318.          (DRAW-STRING TV:ALU-XOR STRING-FONT STRING-TO-DRAW
  319.               (+ TAB-LEF NAME-BORDER-WID NAME-BORDER-SPA)
  320.               (+ TAB-TOP NAME-BORDER-WID NAME-BORDER-SPA))))))
  321.  
  322. (DEFMACRO DRAW-NAME-BORDERS ()
  323.   `(PROGN
  324.      ;; The name row's borders (left, top, right, and bottom)
  325.      (DRAW-RECTANGLE TV:ALU-XOR
  326.              NAME-BORDER-WID             NAME-TAB-HEI
  327.              TAB-LEF                     TAB-TOP)
  328.      (DRAW-RECTANGLE TV:ALU-XOR
  329.              TAB-INNER-WID               NAME-BORDER-WID
  330.              (+ TAB-LEF NAME-BORDER-WID) TAB-TOP)
  331.      (DRAW-RECTANGLE TV:ALU-XOR
  332.              NAME-BORDER-WID             NAME-TAB-HEI
  333.              (- TAB-RIG NAME-BORDER-WID) TAB-TOP)
  334.      (DRAW-RECTANGLE TV:ALU-XOR
  335.              TAB-INNER-WID               NAME-BORDER-WID
  336.              (+ TAB-LEF NAME-BORDER-WID) (- TAB-BOT NAME-BORDER-WID))
  337.      ;; now xor the entire name string for white on black
  338.      (when name-highlight
  339.        (draw-rectangle tv:alu-xor name-row-wid name-row-hei
  340.                (+ TAB-LEF NAME-BORDER-WID NAME-BORDER-SPA)
  341.                (+ TAB-TOP NAME-BORDER-WID NAME-BORDER-SPA)))))
  342.  
  343. ;;;; Stuff for circular structures in the redisplay
  344. (DEFVAR PORT-REDISPLAY-HISTORY NIL)
  345.  
  346. (DEFVAR *PORT-REDISPLAY-DEPTH* 3)
  347.  
  348. (DEFVAR *BOX-ELLIPSIS-WID* 40.)
  349. (DEFVAR *BOX-ELLIPSIS-HEI* 40.)
  350. ;;; Maybe these should be related to BOX-BORDER-PARAMETERS or something...
  351. (DEFVAR *BOX-ELLIPSIS-THICKNESS* 1.)
  352. (DEFVAR *BOX-ELLIPSIS-SPACING*   2.)
  353.  
  354. ;;; The various types of Ellipsi (Ellipses (?)) are stored as symbols in the screen-row
  355. ;;; slots of the screen-box.  The drawing function is the DRAW-SELF property of the symbol
  356. (DEFVAR *DEFINED-BOX-ELLIPSIS-STYLES* NIL)
  357.  
  358. (DEFUN BOX-ELLIPSIS-STYLE? (THING)
  359.   (AND (SYMBOLP THING) (MEMQ THING *DEFINED-BOX-ELLIPSIS-STYLES*)))
  360.  
  361. (DEFMACRO DEFINE-BOX-ELLIPSIS-STYLE (NAME)
  362.   `(PROGN 'COMPILE
  363.       (PUSH ',NAME *DEFINED-BOX-ELLIPSIS-STYLES*)
  364.       ;; default erase adn size properties
  365.       ;; we can overide this with some other definition later
  366.       (DEFUN (:PROPERTY ,NAME ERASE-SELF) (X-COORD Y-COORD)
  367.         (DRAW-RECTANGLE TV:ALU-ANDCA *BOX-ELLIPSIS-WID* *BOX-ELLIPSIS-HEI*
  368.                 X-COORD Y-COORD))
  369.       (DEFUN (:PROPERTY ,NAME SIZE) ()
  370.         (VALUES *BOX-ELLIPSIS-WID* *BOX-ELLIPSIS-HEI*))))
  371.  
  372. (DEFVAR *BOX-ELLIPSIS-CURRENT-STYLE* 'BOX-ELLIPSIS-SOLID-LINES)
  373.  
  374. (DEFMACRO ALTERING-REGION ((REGION) &BODY BODY)
  375.   `(WITHOUT-INTERRUPTS
  376.      (TV:OPEN-BLINKER ,REGION)
  377.      (PROGN . ,BODY)))
  378.  
  379. ;;;****************************************************************;;;
  380. ;;;                      REDISPLAY MACROS                          ;;;
  381. ;;;****************************************************************;;;
  382.  
  383. (DEFMACRO QUEUEING-SCREEN-OBJS-DEALLOCATION (&BODY BODY)
  384.   `(LET ((SCREEN-OBJS-DEALLOCATION-QUEUE NIL))
  385.      (DECLARE (SPECIAL SCREEN-OBJS-DEALLOCATION-QUEUE))
  386.      (UNWIND-PROTECT
  387.      (PROGN . ,BODY)
  388.        (DOLIST (QUEUED-SCREEN-OBJ SCREEN-OBJS-DEALLOCATION-QUEUE)
  389.      (TELL QUEUED-SCREEN-OBJ :DEALLOCATE-SELF)))))
  390.  
  391. (DEFMACRO PORT-REDISPLAYING-HISTORY ((ACTUAL-BOX) &BODY BODY)
  392.   `(LET-IF (PORT-BOX? ,ACTUAL-BOX)
  393.        ((PORT-REDISPLAY-HISTORY (UPDATE-PORT-REDISPLAY-HISTORY ,ACTUAL-BOX)))
  394.      . ,BODY))
  395.  
  396. (DEFMACRO REDISPLAYING-WINDOW ((WINDOW) &BODY BODY)
  397.   `(LET* ((*REDISPLAY-WINDOW* ,WINDOW)
  398.       (*OUTERMOST-SCREEN-BOX* (TELL ,WINDOW :OUTERMOST-SCREEN-BOX))
  399.       (.OUTERMOST-SCREEN-BOX. *OUTERMOST-SCREEN-BOX*))
  400.      (QUEUEING-SCREEN-OBJS-DEALLOCATION 
  401.        (DRAWING-ON-WINDOW (,WINDOW)
  402.      (UNWIND-PROTECT
  403.        (PROGN . ,BODY)
  404.        ;; Check to see if *outermost-screen-box* got changed during
  405.        ;; the redisplay. If it did, then tell the window about it.
  406.        (WHEN (NEQ *OUTERMOST-SCREEN-BOX* .OUTERMOST-SCREEN-BOX.)
  407.          (TELL ,WINDOW :SET-OUTERMOST-SCREEN-BOX *OUTERMOST-SCREEN-BOX*)))))))
  408.  
  409. (DEFMACRO REDISPLAYING-BOX (SCREEN-BOX &BODY BODY)
  410.   ;;this macro sets up the scaling for the redisplay of a particular box without having to
  411.   ;;redisplay the entire screen.  This means that the box to be redisplayed has to be a fixed
  412.   ;;sized box to avoid worrying about propagating changes in size to the superiors of the box.
  413.   `(QUEUEING-SCREEN-OBJS-DEALLOCATION
  414.      (DRAWING-ON-WINDOW (*BOXER-PANE*)
  415.        (MULTIPLE-VALUE-BIND (SUPERIOR-ORIGIN-X-OFFSET SUPERIOR-ORIGIN-Y-OFFSET)
  416.        (TELL (TELL ,SCREEN-BOX :SUPERIOR) :POSITION)
  417.      (LET ((%ORIGIN-X-OFFSET (SCALE-X SUPERIOR-ORIGIN-X-OFFSET))
  418.            (%ORIGIN-Y-OFFSET (SCALE-Y SUPERIOR-ORIGIN-Y-OFFSET)))
  419.        (PROGN . ,BODY))))))
  420.  
  421. ;;; Graphics defs and macros
  422.  
  423. (DEFVAR *DEFAULT-GRAPHICS-SHEET-WIDTH* 320.)
  424.  
  425. (DEFVAR *DEFAULT-GRAPHICS-SHEET-HEIGHT* 200.)
  426.  
  427. (DEFVAR *MAKE-TURTLE-WITH-NEW-GRAPHICS-BOX* NIL
  428.   "Determines if graphics boxes are created with a turtle already in it. ")
  429.  
  430. (DEFSTRUCT (GRAPHICS-SCREEN-SHEET (:TYPE :NAMED-ARRAY)
  431.                   :CONC-NAME
  432.                   (:CONSTRUCTOR %MAKE-G-SCREEN-SHEET
  433.                    (ACTUAL-OBJ X-OFFSET Y-OFFSET))
  434.                   (:PRINT "#<GRAPH-SCR-ST X-~D. Y-~D.>"
  435.                    (GRAPHICS-SCREEN-SHEET-X-OFFSET GRAPHICS-SCREEN-SHEET)
  436.                    (GRAPHICS-SCREEN-SHEET-Y-OFFSET GRAPHICS-SCREEN-SHEET)))
  437.   (X-OFFSET 0.)
  438.   (Y-OFFSET 0.)
  439.   (SCREEN-BOX NIL)
  440.   (ACTUAL-OBJ NIL)
  441.   )
  442.  
  443. (DEFTYPE-CHECKING-MACROS GRAPHICS-SCREEN-SHEET "A screen object for a Graphics Sheet")
  444.  
  445.  
  446. (DEFMACRO DRAWING-ON-TURTLE-SLATE (SCREEN-BOX &BODY BODY)
  447.   ;; this macro sets up the scaling for turtle graphics in absolute SCREEN coordinates
  448.   `(DRAWING-ON-WINDOW (*BOXER-PANE*)
  449.      (MULTIPLE-VALUE-BIND (BOX-X-OFFSET BOX-Y-OFFSET)
  450.      (TELL ,SCREEN-BOX :POSITION)
  451.        (MULTIPLE-VALUE-BIND (INNER-WID INNER-HEI)
  452.        (TELL (TELL ,SCREEN-BOX :ACTUAL-OBJ) :GRAPHICS-SHEET-SIZE)
  453.      (MULTIPLE-VALUE-BIND (SHEET-X SHEET-Y)
  454.          (GRAPHICS-SCREEN-SHEET-OFFSETS (TELL ,SCREEN-BOX :SCREEN-SHEET))
  455.        (LET ((%ORIGIN-X-OFFSET (SCALE-X (+ BOX-X-OFFSET SHEET-X)))
  456.          ;; the x-coord of the upper-left corner of the turtle-array
  457.          (%ORIGIN-Y-OFFSET (SCALE-Y (+ BOX-Y-OFFSET SHEET-Y))))
  458.          ;; the y-coord of the upper-left corner of the turtle-array
  459.          (WITH-CLIPPING-INSIDE (0 0 (MIN INNER-WID (SCREEN-OBJ-WID ,SCREEN-BOX))
  460.                       (MIN INNER-HEI (SCREEN-OBJ-HEI ,SCREEN-BOX)))
  461.            (PROGN . ,BODY))))))))
  462.